home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / graphics / frxfiles / frxfiles.frm < prev    next >
Text File  |  1995-11-11  |  3KB  |  113 lines
  1. VERSION 2.00
  2. Begin Form Form1 
  3.    BorderStyle     =   3  'Fixed Double
  4.    Caption         =   "Extract Pictures"
  5.    ClientHeight    =   1140
  6.    ClientLeft      =   2055
  7.    ClientTop       =   2715
  8.    ClientWidth     =   4695
  9.    Height          =   1920
  10.    Left            =   1950
  11.    LinkTopic       =   "Form1"
  12.    ScaleHeight     =   1140
  13.    ScaleWidth      =   4695
  14.    Top             =   2040
  15.    Width           =   4905
  16.    Begin CommonDialog CMDialog1 
  17.       Left            =   315
  18.       Top             =   1515
  19.    End
  20.    Begin Label Label1 
  21.       FontBold        =   -1  'True
  22.       FontItalic      =   0   'False
  23.       FontName        =   "MS Sans Serif"
  24.       FontSize        =   9.75
  25.       FontStrikethru  =   0   'False
  26.       FontUnderline   =   0   'False
  27.       Height          =   315
  28.       Left            =   885
  29.       TabIndex        =   0
  30.       Top             =   375
  31.       Width           =   3420
  32.    End
  33.    Begin Menu mnuFile 
  34.       Caption         =   "&File"
  35.    End
  36. End
  37. Option Explicit
  38.  
  39. Sub ExtractPictures (fname$)
  40. Dim flong&, counter&, piclen&, c%
  41. Dim hMem%, gptr&, newfile, handle1, handle2
  42. Dim ret&, bmtest%, wmftest&
  43. Dim ext As String * 4
  44. Const WMF = &H9AC6CDD7
  45. Const BM = &H4D42
  46.  
  47.   c = 1
  48.   counter = 1
  49.   flong = FileLen(fname)
  50.     Open fname For Binary As #1
  51.     
  52. Do Until counter >= flong
  53.    Get #1, counter, piclen    'get length of picture
  54.    counter = counter + 4
  55.    If counter + piclen - 1 > flong Then Exit Do ' if its not a picture then piclen could be wrong, and you don't want to read past end of file
  56.  
  57.    Get #1, counter, bmtest
  58.  
  59.    If bmtest = BM Then    'check for bitmap
  60.       ext = ".bmp"
  61.    End If
  62.  
  63.    If bmtest <> BM Then
  64.       Get #1, counter, wmftest    'not a bitmap check for metafile
  65.         If wmftest = WMF Then
  66.             ext = ".wmf"
  67.         Else
  68.             ext = ".ico"        'must be an icon
  69.         End If
  70.    End If
  71.       
  72.       Seek #1, counter
  73.       handle1 = FileAttr(1, 2)
  74.       hMem = GlobalAlloc(GHND, piclen)   'pictures could be over 64K so get memory from global heap
  75.       gptr = GlobalLock(hMem)
  76.       
  77.       ret = hread(handle1, gptr, piclen) 'might be over 64K so use hread
  78.       newfile = FreeFile
  79.          Open App.Path & "\fpic" & c & ext For Binary As newfile
  80.            handle2 = FileAttr(newfile, 2)
  81.            ret = hwrite(handle2, gptr, piclen)  'might be over 64K so use hwrite
  82.            ret = GlobalUnlock(hMem)
  83.            ret = GlobalFree(hMem)
  84.          Close newfile
  85.    counter = counter + piclen
  86.    c = c + 1
  87. Loop
  88.  
  89. Close #1
  90. c = c - 1
  91. Label1 = "You extracted " & c & " pictures"
  92. End Sub
  93.  
  94. Sub mnuFile_Click ()
  95. Dim fname$, num%
  96. On Error Resume Next
  97.   CMDialog1.CancelError = True
  98.   CMDialog1.DialogTitle = "Open FRX File"
  99.   CMDialog1.Filter = "FRX Files | *.frx"
  100.   CMDialog1.Flags = &H1&
  101.   CMDialog1.Action = 1
  102.  
  103. If Err = 0 Then
  104.    fname = CMDialog1.Filename
  105.    If Right$(Trim$(fname), 3) <> "FRX" Then
  106.       MsgBox "This only works on frx files"
  107.       Exit Sub
  108.    End If
  109.    ExtractPictures fname
  110. End If
  111. End Sub
  112.  
  113.